home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / LWP / DebugFile.pm < prev    next >
Text File  |  2008-04-07  |  6KB  |  221 lines
  1. package LWP::DebugFile;
  2.  
  3. use strict;
  4. use LWP::Debug ();
  5.  
  6. use vars qw($outname $outpath @ISA $last_message_time);
  7. @ISA = ('LWP::Debug');
  8.  
  9. _init() unless $^C or !caller;
  10. $LWP::Debug::current_level{'conns'} = 1;
  11.  
  12.  
  13.  
  14. sub _init {
  15.   $outpath = $ENV{'LWPDEBUGPATH'} || ''
  16.    unless defined $outpath;
  17.   $outname = $ENV{'LWPDEBUGFILE'} ||
  18.     sprintf "%slwp_%x_%x.log", $outpath, $^T,
  19.      defined( &Win32::GetTickCount )
  20.       ? (Win32::GetTickCount() & 0xFFFF)
  21.       : $$
  22.         # Using $$ under Win32 isn't nice, because the OS usually
  23.         # reuses the $$ value almost immediately!!  So the lower
  24.         # 16 bits of the uptime tick count is a great substitute.
  25.    unless defined $outname;
  26.  
  27.   open LWPERR, ">>$outname" or die "Can't write-open $outname: $!";
  28.   # binmode(LWPERR);
  29.   {
  30.     no strict;
  31.     my $x = select(LWPERR);
  32.     ++$|;
  33.     select($x);
  34.   }
  35.  
  36.   $last_message_time = time();
  37.   die "Can't print to LWPERR"
  38.    unless print LWPERR "\n# ", __PACKAGE__, " logging to $outname\n";
  39.    # check at least the first print, just for sanity's sake!
  40.  
  41.   print LWPERR "# Time now: \{$last_message_time\} = ",
  42.           scalar(localtime($last_message_time)), "\n";
  43.  
  44.   LWP::Debug::level($ENV{'LWPDEBUGLEVEL'} || '+');
  45.   return;
  46. }
  47.  
  48.  
  49. BEGIN { # So we don't get redefinition warnings...
  50.   undef &LWP::Debug::conns;
  51.   undef &LWP::Debug::_log;
  52. }
  53.  
  54.  
  55. sub LWP::Debug::conns {
  56.   if($LWP::Debug::current_level{'conns'}) {
  57.     my $msg = $_[0];
  58.     my $line;
  59.     my $prefix = '0';
  60.     while($msg =~ m/([^\n\r]*[\n\r]*)/g) {
  61.       next unless length($line = $1);
  62.       # Hex escape it:
  63.       $line =~ s/([^\x20\x21\x23-\x7a\x7c\x7e])/
  64.         (ord($1)<256) ? sprintf('\x%02X',ord($1))
  65.          : sprintf('\x{%x}',ord($1))
  66.       /eg;
  67.       LWP::Debug::_log("S>$prefix \"$line\"");
  68.       $prefix = '+';
  69.     }
  70.   }
  71. }
  72.  
  73.  
  74. sub LWP::Debug::_log
  75. {
  76.     my $msg = shift;
  77.     $msg .= "\n" unless $msg =~ /\n$/;  # ensure trailing "\n"
  78.  
  79.     my($package,$filename,$line,$sub) = caller(2);
  80.     unless((my $this_time = time()) == $last_message_time) {
  81.       print LWPERR "# Time now: \{$this_time\} = ",
  82.         scalar(localtime($this_time)), "\n";
  83.       $last_message_time = $this_time;
  84.     }
  85.     print LWPERR "$sub: $msg";
  86. }
  87.  
  88.  
  89. 1;
  90.  
  91. __END__
  92.  
  93. =head1 NAME
  94.  
  95. LWP::DebugFile - routines for tracing/debugging LWP
  96.  
  97. =head1 SYNOPSIS
  98.  
  99. If you want to see just what LWP is doing when your program calls it,
  100. add this to the beginning of your program's source:
  101.  
  102.   use LWP::DebugFile;
  103.  
  104. For even more verbose debug output, do this instead:
  105.  
  106.   use LWP::DebugFile ('+');
  107.  
  108. =head1 DESCRIPTION
  109.  
  110. This module is like LWP::Debug in that it allows you to see what your
  111. calls to LWP are doing behind the scenes.  But it is unlike
  112. L<LWP::Debug|LWP::Debug> in that it sends the output to a file, instead
  113. of to STDERR (as LWP::Debug does).
  114.  
  115. =head1 OPTIONS
  116.  
  117. The options you can use in C<use LWP::DebugFile (I<options>)> are the
  118. same as the B<non-exporting> options available from C<use LWP::Debug
  119. (I<options>)>.  That is, you can do things like this:
  120.  
  121.   use LWP::DebugFile qw(+);
  122.   use LWP::Debug qw(+ -conns);
  123.   use LWP::Debug qw(trace);
  124.  
  125. The meanings of these are explained in the
  126. L<documentation for LWP::Debug|LWP::Debug>.
  127. The only differences are that by default, LWP::DebugFile has C<cons>
  128. debugging on, ad that (as mentioned earlier), only C<non-exporting>
  129. options are available.  That is, you B<can't> do this:
  130.  
  131.   use LWP::DebugFile qw(trace); # wrong
  132.  
  133. You might expect that to export LWP::Debug's C<trace()> function,
  134. but it doesn't work -- it's a compile-time error.
  135.  
  136. =head1 OUTPUT FILE NAMING
  137.  
  138. If you don't do anything, the output file (where all the LWP debug/trace
  139. output goes) will be in the current directory, and will be named like
  140. F<lwp_3db7aede_b93.log>, where I<3db7aede> is C<$^T> expressed in hex,
  141. and C<b93> is C<$$> expressed in hex.  Presumably this is a
  142. unique-for-all-time filename!
  143.  
  144. If you don't want the files to go in the current directory, you
  145. can set C<$LWP::DebugFile::outpath> before you load the LWP::DebugFile
  146. module:
  147.  
  148.   BEGIN { $LWP::DebugFile::outpath = '/tmp/crunk/' }
  149.   use LWP::DebugFile;
  150.  
  151. Note that you must end the value with a path separator ("/" in this
  152. case -- under MacPerl it would be ":").  With that set, you will
  153. have output files named like F</tmp/crunk/lwp_3db7aede_b93.log>.
  154.  
  155. If you want the LWP::DebugFile output to go a specific filespec (instead
  156. of just a uniquely named file, in whatever directory), instead set the
  157. variable C<$LWP::DebugFile::outname>, like so:
  158.  
  159.   BEGIN { $LWP::DebugFile::outname = '/home/mojojojo/lwp.log' }
  160.   use LWP::DebugFile;
  161.  
  162. In that case, C<$LWP::DebugFile::outpath> isn't consulted at all, and
  163. output is always written to the file F</home/mojojojo/lwp.log>.
  164.  
  165. Note that the value of C<$LWP::DebugFile::outname> doesn't need to
  166. be an absolute filespec.  You can do this:
  167.  
  168.   BEGIN { $LWP::DebugFile::outname = 'lwp.log' }
  169.   use LWP::DebugFile;
  170.  
  171. In that case, output goes to a file named F<lwp.log> in the current
  172. directory -- specifically, whatever directory is current when
  173. LWP::DebugFile is first loaded. C<$LWP::DebugFile::outpath> is still not
  174. consulted -- its value is used only if C<$LWP::DebugFile::outname>
  175. isn't set.
  176.  
  177.  
  178. =head1 ENVIRONMENT
  179.  
  180. If you set the environment variables C<LWPDEBUGPATH> or 
  181. C<LWPDEBUGFILE>, their values will be used in initializing the
  182. values of C<$LWP::DebugFile::outpath>
  183. and C<$LWP::DebugFile::outname>.
  184.  
  185. That is, if you have C<LWPDEBUGFILE> set to F</home/mojojojo/lwp.log>,
  186. then you can just start out your program with:
  187.  
  188.   use LWP::DebugFile;
  189.  
  190. and it will act as if you had started it like this:
  191.  
  192.   BEGIN { $LWP::DebugFile::outname = '/home/mojojojo/lwp.log' }
  193.   use LWP::DebugFile;
  194.  
  195. =head1 IMPLEMENTATION NOTES
  196.  
  197. This module works by subclassing C<LWP::Debug>, (notably inheriting its
  198. C<import>). It also redefines C<&LWP::Debug::conns> and
  199. C<&LWP::Debug::_log> to make for output that is a little more verbose,
  200. and friendlier for when you're looking at it later in a log file.
  201.  
  202. =head1 SEE ALSO
  203.  
  204. L<LWP::Debug>
  205.  
  206. =head1 COPYRIGHT AND DISCLAIMERS
  207.  
  208. Copyright (c) 2002 Sean M. Burke.
  209.  
  210. This library is free software; you can redistribute it and/or modify it
  211. under the same terms as Perl itself.
  212.  
  213. This program is distributed in the hope that it will be useful, but
  214. without any warranty; without even the implied warranty of
  215. merchantability or fitness for a particular purpose.
  216.  
  217. =head1 AUTHOR
  218.  
  219. Sean M. Burke C<sburke@cpan.org>
  220.  
  221.